perm filename SCAN.F4[SCR,LCS] blob
sn#267305 filedate 1977-03-01 generic text, type C, neo UTF8
COMMENT ā VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C ***** SCANNER *************************
C00009 00003 SUBROUTINE BGSORT(BW)
C00014 00004 SUBROUTINE ACCEL
C00020 00005 SUBROUTINE MIXSCR
C00024 ENDMK
Cā;
C ***** SCANNER *************************
C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR 7/74
SUBROUTINE SCANR
DIMENSION IP(30)
COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
1/E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
1 ,(IEN,ISCA(4)),(IP,PL)
C 2/74 IP IS NOW EQUIV TO PL! USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
C WILL THIS DO ANYTHING TO MUSIC5 VERSION??
NNUM=-1
ISKP=0
JJ=0
XMINUS=1.
999 IDECI=-1
M=0
2799 N=INP(ML)
IF(N.NE.IQT)GO TO 899
JA=-1
ML=ML+1
ISUB=8
JJ=JJ+1
VX(JJ)=ML
C POINTS TO FIRST LIT. CHAR.
DO 1177 K=ML,144
IF(INP(K).NE.IQT)GO TO 1177
ML=K+1
2177 N=INP(ML)
GO TO 899
1177 CONTINUE
C SKIPS 'LIT' ITEMS IN RAN. SELECTION
899 ML=ML+1
IF(N.EQ.ISEMI)GO TO 751
IF(N.NE.IBLA)GO TO 510
4702 IF(ISKP)202,2799,2799
510 IF(JA)GO TO 70
C********** MAY 22,71
DO 77 K=1,12
IF(N.NE.ISCA(K))GO TO 77
IF(K.EQ.2)GO TO 1511
IF(K.NE.4)GO TO 511
1511 NSWCH=K-4
GO TO 2177
C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
C ************ MAY 22,71
511 NNUM=K
JJ=JJ+1
NFLG=-1
N=INP(ML)
IF(N.NE.IF)GO TO 410
NNUM=NNUM-1
GO TO 610
410 IF(N.NE.ISS)GO TO 3410
NNUM=NNUM+1
610 ML=ML+1
N=INP(ML)
3410 IF(N.EQ.IEN)GO TO 3411
IF(N.NE.'I')GO TO 371
C 'END' OR 'FINE' WILL END INST.
C******** MAY 20,71
3411 VX(JJ)=10000.
IF(DUR(LK))DUR(LK)=1000.
IAMP=-1
RETURN
371 IF(N.EQ.ISEMI)GO TO 5410
IF(N.EQ.IBLA)GO TO 5410
DO 177 KN=2,9
IF(N.NE.IDAT(KN))GO TO 177
IF(KN.EQ.9)CALL ERR(4)
C FOUND OCTAVE NUM.8 -- TOO HIGH!
JSCA=KN-2
ML=ML+1
GO TO 2410
177 CONTINUE
GO TO 6410
5410 KN=-1
6410 IF(NSWCH.EQ.0)GO TO 2410
IF(KN)GO TO 7410
CC IF(N.EQ.'+')NOLD=NOLD+6
CC IF(N.EQ.'-')NOLD=NOLD-6
C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
7410 IF(NOLD-NNUM.LE.5)GO TO 7411
IF(JSCA.LT.7)JSCA=JSCA+1
7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
IF(JSCA.GT.0)JSCA=JSCA-1
C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
2410 VX(JJ)=JSCA*12+NNUM
NOLD=NNUM
C ********** MAY 22,71
4410 NNUM=-2
IF(INP(ML).EQ.ISEMI)RETURN
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
IF(N.EQ.IXX)GO TO 210
IF(N.EQ.'*')GO TO 210
GO TO 310
C *********MAY 22,71
77 CONTINUE
70 IF(N.NE.'-')GO TO 71
XMINUS=-1.
GO TO 2799
210 JJ=JJ+1
IF(JJ.EQ.1)GO TO 3310
C****** MAY 19,71
XMINUS=1.
VX(JJ)=0
C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
GO TO 310
71 IF(N.EQ.IXX)GO TO 210
IF(N.EQ.'*')GO TO 210
IF(N.EQ.'R')GO TO 73
1410 DO 78 K=1,11
IF(N.NE.IDAT(K))GO TO 78
ISKP=-1
IF(N.NE.IDOT)GO TO 79
IDECI=M
GO TO 75
79 M=M+1
IP(M)=K-1
GO TO 75
78 CONTINUE
IF(N.NE.IE)GO TO 8811
IF(INP(ML).NE.IEN)GO TO 781
GO TO 7811
8811 IF(N.NE.IF)GO TO 781
IF(INP(ML).NE.'I')GO TO 781
C 'EN(D)' OR 'FI(NE)' WILL END INST.
7811 JJ=1
GO TO 3411
781 IF(N.EQ.'/')N=ISEMI
C FOR MOTIVIC TRANFORMATIONS
75 KN=INP(ML)
IF(KN.NE.IXX)GO TO 175
IF(INP(ML+1).NE.'(')GO TO 202
C "X(" STARTS A 'MOTIF' BUT "X (" WON'T WORK!!!!
175 IF(KN.EQ.'*')GO TO 202
C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
CC75 IF(INP(ML).NE.IXX)GO TO 752
CC ML=ML-1
CC GO TO 202
C FOR 'X' AND '*' WITHOUT SPACES.
IF(N.EQ.ISEMI)GO TO 751
IF(KN.NE.1)GO TO 2799
C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
751 IF(ISKP.EQ.0)RETURN
202 IF(IDECI.NE.-1)GO TO 302
IDECI=0
GO TO 402
302 IDECI=M-IDECI
402 KN=0
IEXP=M-1
IF(M.LT.1)M=1
DO 171 K=1,M
KV=10**IEXP
IF(IEXP.EQ.0)KV=1
KN=KN+IP(K)*KV
171 IEXP=IEXP-1
A=10**IDECI
IF(IDECI.EQ.0)A=1.
JJ=JJ+1
VX(JJ)=KN/A*XMINUS
IF(ISUB.EQ.1)RETURN
IF(CODE.NE.-22.)XMINUS=1.
C ONLY ONE - NEEDED FOR RHY.COMPOSITE
1310 IF(INP(ML).NE.1)GO TO 310
VX(JJ+1)=VX(JJ)*2.
JJ=JJ+1
ML=ML+1
GO TO 1310
206 ML=ML+2
3310 VX(1)=-99.
C******** MAY 19,71
310 ISKP=0
IF(N.NE.ISEMI)GO TO 999
RETURN
73 JJ=JJ+1
IF(INP(ML).EQ.IE)GO TO 206
C NEXT IS FOR A REST ('R')
VX(JJ)=85.
C 7/75 GO TO 4410
731 N=INP(ML)
IF(N.EQ.'/')RETURN
IF(N.EQ.ISEMI)RETURN
IF(N.NE.IBLA)GO TO 899
ML=ML+1
GO TO 731
END
SUBROUTINE BGSORT(BW)
C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
C ALLOWS 100 BG TIMES.
COMMON /Q/ BNW(100),NWZ
DO 5308 K=1,NWZ
X=BNW(K)-.0001
Y=X+.0002
C ROUND-OFF NONSENSE
IF(BW.LE.X)GO TO 5308
IF(BW.LT.Y)RETURN
5308 CONTINUE
NWZ=NWZ+1
BNW(NWZ)=BW
RETURN
END
SUBROUTINE FMT(JFM,INP,MLX)
DIMENSION JFM(3),INP(1)
DO 1 MLX=2,72
J=INP(MLX)
IF(J.EQ.' ')GO TO 2
IF(J.EQ.',')GO TO 2
IF(J.EQ.';')GO TO 2
1 IF(J.EQ.':')GO TO 3
C SPACE=COMMA=SPACE, ALSO STOPS ON ";"
3 CALL ERR(1)
C ERROR IF COLON IS FOUND OR THERE IS NO END MARK
2 MLX=MLX+1
IF(MLX.GT.7)MLX=7
JFM(2)='0'+(MLX-2)*536870912
C FINDS NUMBER FOR 'A' FORMAT
END
SUBROUTINE RANR(VX,K)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
DIMENSION VX(1)
X=VX(K)
Y=VX(K+1)
IF(X.GT.Y)VX(K)=X+.999
IF(Y.GE.X)VX(K+1)=Y+.999
RETURN
END
SUBROUTINE SQYY(YY,X,Y,Z)
YY=2.*Z/(X+Y)
IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
RETURN
END
SUBROUTINE COLTTY(JNP,JT)
COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED /FRMT/J(2)
DIMENSION JNP(1)
DATA J(2)/'72A1)'/
DO 1 K=72,1,-1
1 IF(JNP(K).NE.' ')GO TO 2
K=1
2 IF(JT.EQ.21)GO TO 3
J(1)=' (1X'
IF(LN.EQ.0)GO TO 5
J(1)='(I6,X'
WRITE(JT,J)LN,(JNP(L),L=1,K)
RETURN
3 J(1)=' ('
5 WRITE(JT,J)(JNP(L),L=1,K)
END
FUNCTION READER(JNP)
DIMENSION JNP(72)
COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
1 /FRMT/J(2)
DATA TPALN/20H(' TYPE A LINE'/) /
J(1)=' ('
READER=0
IF(ITYP)GO TO 1
6 TYPE TPALN
ACCEPT J,JNP
IF(JED)CALL COLTTY(JNP,21)
IF(JNP(1).EQ.' ')GO TO 6
RETURN
1 IF(LN.NE.0)GO TO 5
READ(1,J,END=3)JNP
GO TO 7
5 J(1)=' (I,'
READ(1,J,END=3)LN,JNP
7 IF(SOS)CALL COLTTY(JNP,JOUT)
RETURN
3 READER=-1
END
SUBROUTINE QUAD
C DUMMY -- FOR NOW. 7/74
END
FUNCTION RMOVX(W,Y,Z)
IF(W.EQ.0)W=.01
IF(Y.EQ.0)Y=.01
RMOVX=Y*((W/Y)**Z)
END
SUBROUTINE CLEAN(INP,LEND)
DIMENSION INP(1)
C CLEAR THE END OF ARRAY
M=72
LEND=-1
K=0
1 K=K+1
NN=INP(K)
IF(NN.EQ.';')GO TO 2
IF(NN.EQ.'/')GO TO 2
IF(NN.EQ.'<')GO TO 3
C USE < FOR COMMENT-- AS IN MUS10
IF(NN.EQ.',')INP(K)=' '
C CHANGE ALL COMMAS TO BLANKS
IF(NN.EQ.':')CALL ERR(1)
IF(NN.NE.'"')GO TO 4
7 K=K+1
IF(INP(K).EQ.'"')GO TO 4
IF(K.LT.M)GO TO 7
CALL ERR(5)
2 LEND=K
4 IF(K.LT.M)GO TO 1
3 IF(LEND.GT.0)RETURN
IF(M.EQ.144)CALL ERR(2)
CALL READER(INP(73))
C GO READ ANOTHER LINE.
M=144
K=72
GO TO 1
END
SUBROUTINE ERR(K)
GO TO(1,2,3,4,5)K
TYPE 199,K
199 FORMAT(' ERROR!! LAST LINE READ =',I6)
CALL EXIT
1 TYPE 11
CALL EXIT
11 FORMAT(' ILLEGAL COLON')
2 TYPE 12
CALL EXIT
12 FORMAT(' NO END MARK')
3 TYPE 13
CALL EXIT
13 FORMAT(' MORE THAN 2 PARENS OPEN')
4 TYPE 14
CALL EXIT
14 FORMAT(' SOME NUMBER TOO BIG')
5 TYPE 15
CALL EXIT
15 FORMAT(' OPEN QUOTES')
END
SUBROUTINE ACCEL
COMMON/VV/LIMIT,V(1)/A/ROFF(27),NP(27),PCH(27,32),
1 RDEV(27),IPT(27,31),XT(27),OTH(20,16),SCAL(101)
1 ,P1(27),JFM(4),COPY(30),IFM(80)
1 ,FINM(6),TINST(5),ENFI(5),TEDIT(4),INVIS(27)
COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
COMMON/B/MOT,PR,T5,NINS,I,TP,RA,KZY,NWX,INONLY,MX,
1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
1 ZZ,CHN,YY
1 /C/LPAR,IPRN,QX,RETRO,INVRT,ICON,LCNT,
1 PARENS,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
1 LP,ILIT,NLIT,KTMP,IC,NONO,RD,IA
C /C/=26
IF(T5.EQ.1)GO TO 4020
XA=RA
7020 RA=V(IA+K)
IF(RA.EQ.10000.)RETURN
4020 RD=1
IF(RA.LT.0)RD=-1.
RA=RA*RD
IF(KA.EQ.0)RA=RA-RC
W=RA
RB=W
IF(W.LE.Z)GO TO 2020
IF(Z.NE.0)GO TO 3020
RA=RA/Y
RB=-1.
RC=0
GO TO 8020
3020 W=Z
RC=W+RC
GO TO 24
2020 RC=0
24 IF(X.NE.Y)GO TO 424
RA=W/X
GO TO 8020
C DUR OF TMP + BG TIME OF TMP - NOTE VALUE -
C BG TIME OF NOTE. CHN=TBG.
424 RAX=XT(J)
RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
XT(J)=RAX+YY*RA
8020 IF(KA.EQ.0)RA=RA+XA
KA=1
IF(RC.NE.0)GO TO 1011
IF(T5.EQ.1)RETURN
C T5=1 IN 'RUNIT'
V(IA+K)=RA*RD
IF(K.EQ.IZ)RETURN
C*********** JUNE 1,71
1011 IF(T5.EQ.1)GO TO 2011
K=K+1
IF(ZZ.NE.0)Z=Z-W
IF(Z.GT.0)GO TO 7020
IF(RB.EQ.-1.)GO TO 7020
IC=IC+1
IF(RB.EQ.W)RETURN
KA=0
K=K-1
RETURN
2011 XA=RA
IF(K.GT.1)GO TO 9020
K=I-6
ZPAR=-9900.-CHN-ZZ
DO 3011 KL=8,I
IF(V(K).NE.ZPAR)GO TO 3011
IF(V(K+1).EQ.990000.)GO TO 9020
3011 K=K-1
9020 W=ZZ
IF(V(K+3))K=K+3
C ABOVE IS FOR TYPED IN TEMPO CHANGES
KA=K+3
ZZ=V(KA)
C DUR OF NEXT TEMPI
X=V(KA+1)
Y=V(KA+2)
213 KA=0
Z=ZZ
CALL SQYY(YY,X,Y,Z)
CHN=CHN+W
XT(J)=X
IF(KA.EQ.1)Z=0
RA=PR
KA=0
K=K+3
GO TO 4020
END
SUBROUTINE POINTR(INUM,IPAR,ISTRT,KODE)
COMMON/VV/LIMIT, V(2000)
C TO FIND POINTERS TO LISTS, ETC. IN V ARRAY WHEN USING SUBR.
C KODES: -22=RHY -33=NOTES -44=NUMS -46=RLIST -36=RNOTES
C -11=SUBN -12=SUBR -55=MOVE NUMS -56=MOVE NOTES
C -66=DUPL -88=LIT -57=MOVE RANGE NUMS -58=MOVE RNG NOTES
DO 1 K=1,2000
N=V(K)
IF(N.LT.10000)GO TO 1
IF(N/10000.NE.INUM)GO TO 1
IF(MOD(N,10000).NE.IPAR)GO TO 1
ISTRT=K+4
KODE=V(K+2)
ICNT=V(K+3)
IF(IABS(KODE).LT.11)ISTRT=ISTRT-1
RETURN
C FINDS FIRST OCCURRENCE OF PARAM AND INST ONLY.
1 CONTINUE
END
SUBROUTINE NMCHG
DIMENSION RNAME(5),JNM(5)
COMMON /INS/ INST(27),BG(60)
COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST,DF,DUR(27)
COMMON/VV/LIMIT, V(1) /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,IL
1,KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2,T1,RD,VIJ2
EQUIVALENCE (RNAME,JNM)
DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
DATA MM/"774000000000/
P(IPAR)=0
C REPLACE NAME BY A ZERO FOR THIS PARAM.
PL(IPAR)=1.
J=PM-1
C PM POINTS TO 1ST WORD OF LIT. STRING., PAR= LAST
N=V(J)
C THE WORD COUNT
DO 15 K=1,5
J=J+1
X=V(J)
IF(K.GT.N)X=' '
15 RNAME(K)=X
C N=WDCNT OF INST NAME
NN=0
DO 10 K=5,1,-1
NN=NN .OR. (JNM(K) .AND. MM)
IF (K-1) 20,20,17
17 IF (NN.GE.0)GO TO 13
NN = (( NN .AND. LL)/KK) .OR. JJ
GO TO 10
13 NN = NN / KK
10 CONTINUE
20 INST(INUM)=NN
END
SUBROUTINE MIXSCR
COMMON /VV/Q(19),R(19),KL,N1,N2,N3,J,K,L,M,P1,PX
TYPE 24
200 TYPE 20
ACCEPT 21,N1
IF(N1.EQ.' ')GO TO 200
201 TYPE 22
ACCEPT 21,N2
IF(N2.EQ.' ')GO TO 201
202 TYPE 23
ACCEPT 21,N3
IF(N3.EQ.' ')GO TO 202
CALL OFILE(1,N3)
CALL IFILE(21,N1)
CALL IFILE(22,N2)
DO 1 K=1,3
READ(21,2)Q
WRITE(1,26)Q
1 READ(22,2)Q
C READS FIRST 3 LINES
33 READ(21,30)L,N,K,Q
IF(Q(5).NE.' ')GO TO 32
IF(Q(10).NE.'.')GO TO 32
GO TO 31
CC IF(Q(19).EQ.'.')GO TO 31
CATCHES INSERTED LINES.
32 REREAD 44,L,Q
WRITE(21,46)L,Q
GO TO 33
31 REREAD 4,L,N,P1,Q
34 READ(22,30)L,M,K,R
IF(R(5).NE.' ')GO TO 35
IF(R(10).NE.'.')GO TO 35
GO TO 36
CC IF(R(19).EQ.'.')GO TO 36
CATCHES INSERTED LINES.
35 REREAD 44,L,R
WRITE(22,46)L,R
GO TO 34
36 REREAD 4,L,M,PX,R
TYPE 25
25 FORMAT(' WORKING')
6 IF(PX.LT.P1)GO TO 5
CALL RDWRT(N,P1,Q,21)
IF(KL)10,6,6
5 CALL RDWRT(M,PX,R,22)
IF(KL.EQ.0)GO TO 6
11 IF(N.EQ.M)GO TO 12
PX=10000
GO TO 6
10 IF(N.EQ.M)GO TO 12
P1=10000
GO TO 6
12 WRITE(1,7)
END FILE 1
TYPE 203,N3
CALL EXIT
203 FORMAT(' ****** FILE NAME = ',A5,'.DAT')
30 FORMAT(22A1)
2 FORMAT(19A5)
44 FORMAT(A1,20A5)
46 FORMAT(1XA1,20A5)
26 FORMAT(1X19A5)
4 FORMAT(A1,A5,F,19A5)
7 FORMAT(' FINISH;')
24 FORMAT(' MIXES SCORE LISTS.'/
1' USES ".DAT" EXTENSIONS ONLY!!! '/
1' BE SURE ALL HIGHER PARAMS PRINT EACH TIME.')
20 FORMAT(' TYPE FILE 1 (WITHOUT EXT.) '$)
22 FORMAT(' TYPE FILE 2 '$)
21 FORMAT(A5)
23 FORMAT(' TYPE OUTPUT NAME '$)
END
SUBROUTINE SHORT(Q,K)
DIMENSION Q(1)
K=19
DO 1 K=19,1,-1
1 IF(Q(K).NE.' ')RETURN
END
SUBROUTINE RDWRT(I,P,R,J)
COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K
DIMENSION R(19)
KL=0
CALL SHORT(R,K)
WRITE(1,40)L,I,P,(R(N),N=1,K)
1 READ(J,44)L,I,R
CALL SRDWRT(I,R)
CC CALL SHORT(R,K)
CC WRITE(1,44)L,I,(R(N),N=1,K)
IF(I.NE.'PRINT')GO TO 1
2 READ(J,4)L,I,P,R
IF(I.EQ.' SEG(')GO TO 3
IF(I.EQ.' SYNT')GO TO 3
IF(I.EQ.'FINIS')KL=-1
RETURN
3 REREAD 44,L,I,R
GO TO 9
13 READ(J,44)L,I,R
CC9 CALL SHORT(R,K)
CC WRITE(1,44)L,I,(R(N),N=1,K)
9 CALL SRDWRT(I,R)
IF(I.NE.'PRINT')GO TO 13
C THIS IS FOR SEG AND SYNTH LINES
GO TO 2
44 FORMAT(A1,20A5)
40 FORMAT(1XA1,A5,F8.2,19A5)
4 FORMAT(A1,A5,F,19A5)
END
SUBROUTINE SRDWRT(I,R)
COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K
DIMENSION R(19)
CALL SHORT(R,K)
WRITE(1,44)L,I,(R(N),N=1,K)
44 FORMAT(1XA1,20A5)
END